home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / ANIMATE.LZH / KEYDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1984-09-14  |  6KB  |  156 lines
  1. Program KeyDemo;
  2. type
  3.   BitType = 1..8;
  4. var
  5.   ToggleByte : byte absolute $40:$17;
  6.   ScreenSeg  : integer;
  7.   C, D       : char;
  8.   done       : boolean;
  9. {============================================================================}
  10. procedure illumination(N: BitType;light : boolean);    {Here I am "poking"   }
  11. var                                                    {an attribute byte    }
  12.   LocationCode : integer;                              {into the screen      }
  13.   Row,Col,Pos,LightLevel  : byte;                      {memory--15 is bright }
  14. begin                                                  {and 112 is reverse.  }
  15.   if light then LightLevel := 112 else LightLevel := 15;
  16.   Row := ((N-1) div 4) + 1;
  17.   Col := ((N-1) mod 4)*15;
  18.   for Pos := Col + 2 to Col + 15 do
  19.     begin
  20.       LocationCode := (Pos-1)*2 + (row-1)*160 + 1;
  21.       Mem[ScreenSeg:locationCode] := LightLevel;
  22.     end;
  23. end;
  24. {=======================================================================}
  25. procedure ToggleNames;
  26. begin
  27.   WriteLn('*   INSERT     *   CAPS LOCK  *    NUM LOCK  *  SCROLL LOCK *');
  28.   WriteLn('*     ALT      *    CONTROL   *   LEFT SHIFT *  RIGHT SHIFT *');
  29. end;
  30. {=======================================================================}
  31. procedure CheckStatus;             {ToggleByte is declared above at an }
  32. var                                {absolute location that happens to  }
  33.   N : BitType;                     {hold the status (on or off) of the }
  34.   checker : byte;                  {eight keys shown in its eight bits.}
  35. begin
  36.   checker := 1;
  37.   for N := 8 downto 1 do
  38.     begin
  39.       if ToggleByte and checker = checker then illumination(N,true)
  40.         else illumination(N,false);
  41.       checker := 2*checker;
  42.     end;
  43.   if ToggleByte and 10 = 10 then Done := true; {if left shift AND Alt are on}
  44. end;
  45. {=======================================================================}
  46. procedure GetKeys(var choice, EscChoice:char);      { This is a handy      }
  47. begin                                               { procedure.  It       }
  48.   repeat CheckStatus until KeyPressed or Done;      { waits for a key      }
  49.   EscChoice := chr(0);                              { to be pressed and    }
  50.   if not Done then                                  { reads it.  If the    }
  51.     begin                                           { keypressed function  }
  52.       read(Kbd,choice);                             { is still TRUE, it    }
  53.       if keypressed then read(Kbd,EscChoice);       { reads the Escape code}
  54.     end;
  55. end;
  56. {=======================================================================}
  57. procedure WhatKeys;
  58.   begin
  59.   GetKeys(C,D);
  60.   if not Done then
  61.     begin
  62.       gotoXY(10,10);
  63.       write('           ');
  64.       gotoXY(11,10);
  65.     if C = chr(27) then
  66.       begin
  67.         if D = chr(0) then write('Esc');
  68.         Case D of
  69.           ';': write('F1');
  70.           '<': write('F2');
  71.           '=': write('F3');
  72.           '>': write('F4');
  73.           '?': write('F5');
  74.           '@': write('F6');
  75.           'A': write('F7');
  76.           'B': write('F8');
  77.           'C': write('F9');
  78.           'D': write('F10');
  79.           'h': write('Alt-F1');
  80.           'i': write('Alt-F2');
  81.           'j': write('Alt-F3');
  82.           'k': write('Alt-F4');
  83.           'l': write('Alt-F5');
  84.           'm': write('Alt-F6');
  85.           'n': write('Alt-F7');
  86.           'o': write('Alt-F8');
  87.           'p': write('Alt-F9');
  88.           'q': write('Alt-F10');
  89.           'T': write('Shift-F1');
  90.           'U': write('Shift-F2');
  91.           'V': write('Shift-F3');
  92.           'W': write('Shift-F4');
  93.           'X': write('Shift-F5');
  94.           'Y': write('Shift-F6');
  95.           'Z': write('Shift-F7');
  96.           '[': write('Shift-F8');
  97.           '\': write('Shift-F9');
  98.           ']': write('Shift-F10');
  99.           '^': write('Ctrl-F1');
  100.           '_': write('Ctrl-F2');
  101.           '`': write('Ctrl-F3');
  102.           'a': write('Ctrl-F4');
  103.           'b': write('Ctrl-F5');
  104.           'c': write('Ctrl-F6');
  105.           'd': write('Ctrl-F7');
  106.           'e': write('Ctrl-F8');
  107.           'F': write('Ctrl-F9');
  108.           'g': write('Ctrl-F10');
  109.           'G': write('Home');
  110.           'H': write('Up');
  111.           'I': write('PgUp');
  112.           'K': write('Left');
  113.           'M': write('Right');
  114.           'O': write('End');
  115.           'P': write('Down');
  116.           'Q': write('PgDn');
  117.           'R': write('Ins');
  118.           'S': write('Del');
  119.           'w': write('Ctrl-Home');
  120.           'ä': write('Ctrl-PgUp');
  121.           's': write('Ctrl-LeFt');
  122.           't': write('Ctrl-Right');
  123.           'u': write('Ctrl-End');
  124.           'v': write('Ctrl-PgDn');
  125.           'r': write('Ctrl-prtsc');
  126.         end;  {case statement}
  127.       end   {if C = chr(27)}
  128.     else
  129.       case ord(C) of
  130.            9 : write('Tab');
  131.            8 : write('BackSpace');
  132.       else write(C);
  133.       end;   {case}
  134.     end;  {if not done}
  135. end;  {procedure GetKeys}
  136. {============================================================================}
  137. begin
  138.   IF (Mem[0000:1040] AND 48) <> 48 THEN ScreenSeg := $B800
  139.    ELSE ScreenSeg := $B000; {set screen memory segment to color or mono}
  140.   WriteLn('Play with the keys.  This program recognizes only SPECIAL');
  141.   WriteLn('keystrokes, such as the function and arrow keys.  It also');
  142.   WriteLn('tracks the toggles and shift keys.  Hit a key to start.');
  143.   WriteLn;
  144.   WriteLn('Press <Alt> and the left <shift> at once to quit.');
  145.   done := false;
  146.   repeat until KeyPressed;
  147.   ClrScr;
  148.   ToggleNames;
  149.   GotoXY(5,6);
  150.   Write('Press <Alt> and the left <shift> at once to quit.');
  151.   GotoXY(1,10);
  152.   Write('Key is->>> ');
  153.   repeat
  154.     WhatKeys
  155.   until Done;
  156. end.